home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / typetran.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  15.0 KB  |  420 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: typetran.lisp,v 1.14 92/04/27 19:46:44 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains stuff that implements the portable IR1 semantics of
  15. ;;; type tests.  The main thing we do is convert complex type tests into
  16. ;;; simpler code that can be compiled inline.
  17. ;;;
  18. ;;; Written by Rob MacLachlan
  19. ;;;
  20. (in-package "C")
  21.  
  22.  
  23. ;;;; Type predicate translation:
  24. ;;;
  25. ;;;    We maintain a bidirectional association between type predicates and the
  26. ;;; tested type.  The presence of a predicate in this association implies that
  27. ;;; it is desirable to implement tests of this type using the predicate.  This
  28. ;;; is true both of very simple types.  These are either predicates that the
  29. ;;; back end is likely to have special knowledge about, or predicates so
  30. ;;; complex that the only reasonable implentation is via function call.
  31. ;;;
  32. ;;;    Some standard types (such as SEQUENCE) are best tested by letting the
  33. ;;; TYPEP source transform do its thing with the expansion.  These types (and
  34. ;;; corresponding predicates) are not maintained in this association.  In this
  35. ;;; case, there need not be any predicate function unless it is required by
  36. ;;; Common Lisp.
  37. ;;;
  38. ;;;    The mappings between predicates and type structures is stored in the
  39. ;;; backend structure, so that different backends can support different sets
  40. ;;; of predicates.
  41. ;;;
  42.  
  43. ;;; Define-Type-Predicate  --  Interface
  44. ;;;
  45. (defmacro define-type-predicate (name type)
  46.   "Define-Type-Predicate Name Type
  47.   Establish an association between the type predicate Name and the
  48.   corresponding Type.  This causes the type predicate to be recognized for
  49.   purposes of optimization."
  50.   `(%define-type-predicate ',name ',type))
  51. ;;;
  52. (defun %define-type-predicate (name specifier)
  53.   (let ((type (specifier-type specifier)))
  54.     (setf (gethash name (backend-predicate-types *target-backend*)) type)
  55.     (setf (backend-type-predicates *target-backend*)
  56.       (cons (cons type name)
  57.         (remove name (backend-type-predicates *target-backend*)
  58.             :key #'cdr)))
  59.     (%deftransform name '(function (t) *) #'fold-type-predicate)
  60.     name))
  61.  
  62.  
  63. ;;;; IR1 transforms:
  64.  
  65. ;;; Typep IR1 transform  --  Internal
  66. ;;;
  67. ;;;    If we discover the type argument is constant during IR1 optimization,
  68. ;;; then give the source transform another chance.  The source transform can't
  69. ;;; pass, since we give it an explicit constant.  At worst, it will convert to
  70. ;;; %Typep, which will prevent spurious attempts at transformation (and
  71. ;;; possible repeated warnings.) 
  72. ;;;
  73. (deftransform typep ((object type))
  74.   (unless (constant-continuation-p type)
  75.     (give-up "Can't open-code test of non-constant type."))
  76.   `(typep object ',(continuation-value type)))
  77.  
  78.  
  79. ;;; IR1-Transform-Type-Predicate  --  Internal
  80. ;;;
  81. ;;;    If the continuation Object definitely is or isn't of the specified type,
  82. ;;; then return T or NIL as appropriate.  Otherwise quietly Give-Up.
  83. ;;;
  84. (defun ir1-transform-type-predicate (object type)
  85.   (declare (type continuation object) (type ctype type))
  86.   (let ((otype (continuation-type object)))
  87.     (cond ((not (types-intersect otype type)) 'nil)
  88.       ((csubtypep otype type) 't)
  89.       (t (give-up)))))
  90.  
  91.  
  92. ;;; %Typep IR1 transform  --  Internal
  93. ;;;
  94. ;;;    Flush %Typep tests whose result is known at compile time.
  95. ;;;
  96. (deftransform %typep ((object type))
  97.   (unless (constant-continuation-p type) (give-up))
  98.   (ir1-transform-type-predicate
  99.    object
  100.    (specifier-type (continuation-value type))))
  101.  
  102. ;;; Fold-Type-Predicate IR1 transform  --  Internal
  103. ;;;
  104. ;;;    This is the IR1 transform for simple type predicates.  It checks whether
  105. ;;; the single argument is known to (not) be of the appropriate type, expanding
  106. ;;; to T or NIL as apprporiate.
  107. ;;;
  108. (deftransform fold-type-predicate ((object) * * :node node :defun-only t)
  109.   (let ((ctype (gethash (leaf-name
  110.              (ref-leaf
  111.               (continuation-use
  112.                (basic-combination-fun node))))
  113.             (backend-predicate-types *backend*))))
  114.     (assert ctype)
  115.     (ir1-transform-type-predicate object ctype)))
  116.  
  117.  
  118. ;;;; Standard type predicates:
  119.  
  120. (defun define-standard-type-predicates ()
  121.   (define-type-predicate arrayp array)
  122.   ; No atom.  Use (not cons) deftype.
  123.   (define-type-predicate bit-vector-p bit-vector)
  124.   (define-type-predicate characterp character)
  125.   (define-type-predicate compiled-function-p compiled-function)
  126.   (define-type-predicate complexp complex)
  127.   (define-type-predicate consp cons)
  128.   (define-type-predicate floatp float)
  129.   (define-type-predicate functionp function)
  130.   (define-type-predicate integerp integer)
  131.   (define-type-predicate keywordp keyword)
  132.   (define-type-predicate listp list)
  133.   (define-type-predicate null null)
  134.   (define-type-predicate numberp number)
  135.   (define-type-predicate rationalp rational)
  136.   (define-type-predicate simple-bit-vector-p simple-bit-vector)
  137.   (define-type-predicate simple-string-p simple-string)
  138.   (define-type-predicate simple-vector-p simple-vector)
  139.   (define-type-predicate stringp string)
  140.   (define-type-predicate structurep structure)
  141.   (define-type-predicate symbolp symbol)
  142.   (define-type-predicate vectorp vector))
  143.  
  144. (define-standard-type-predicates)
  145.  
  146.  
  147.  
  148. ;;;; Transforms for type predicates not implemented primitively:
  149. ;;;
  150. ;;; See also VM dependent transforms.
  151.  
  152. (def-source-transform atom (x)
  153.   `(not (consp ,x)))
  154.  
  155.  
  156. ;;;; Typep source transform:
  157.  
  158. ;;; Transform-Numeric-Bound-Test  --  Internal
  159. ;;;
  160. ;;;    Return a form that tests the variable N-Object for being in the binds
  161. ;;; specified by Type.  Base is the name of the base type, for declaration.  We
  162. ;;; make safety locally 0 to inhibit any checking of this assertion.
  163. ;;;
  164. (defun transform-numeric-bound-test (n-object type base)
  165.   (declare (type numeric-type type))
  166.   (let ((low (numeric-type-low type))
  167.     (high (numeric-type-high type)))
  168.     `(locally
  169.        (declare (optimize (safety 0)))
  170.        (and ,@(when low
  171.         (if (consp low)
  172.             `((> (the ,base ,n-object) ,(car low)))
  173.             `((>= (the ,base ,n-object) ,low))))
  174.         ,@(when high
  175.         (if (consp high)
  176.             `((< (the ,base ,n-object) ,(car high)))
  177.             `((<= (the ,base ,n-object) ,high))))))))
  178.  
  179.  
  180. ;;; Source-Transform-Numeric-Typep  --  Internal
  181. ;;;
  182. ;;;    Do source transformation of a test of a known numeric type.  We can
  183. ;;; assume that the type doesn't have a corresponding predicate, since those
  184. ;;; types have already been picked off.  In particular, Class must be
  185. ;;; specified, since it is unspecified only in NUMBER and COMPLEX.  Similarly,
  186. ;;; we assume that Complexp is always specified.
  187. ;;;
  188. ;;;    For non-complex types, we just test that the number belongs to the base
  189. ;;; type, and then test that it is in bounds.  When Class is Integer, we check
  190. ;;; to see if the range is no bigger than FIXNUM.  If so, we check for FIXNUM
  191. ;;; instead of INTEGER.  This allows us to use fixnum comparison to test the
  192. ;;; bounds.
  193. ;;;
  194. ;;;    For complex types, we must test for complex, then do the above on both
  195. ;;; the real and imaginary parts.  When Class is float, we need only check the
  196. ;;; type of the realpart, since the format of the realpart and the imagpart
  197. ;;; must be the same.
  198. ;;;
  199. (defun source-transform-numeric-typep (object type)
  200.   (let* ((class (numeric-type-class type))
  201.      (base (ecase class
  202.          (integer (containing-integer-type type))
  203.          (rational 'rational)
  204.          (float (or (numeric-type-format type) 'float))
  205.          ((nil) 'number))))
  206.     (once-only ((n-object object))
  207.       (ecase (numeric-type-complexp type)
  208.     (:real
  209.      `(and (typep ,n-object ',base)
  210.            ,(transform-numeric-bound-test n-object type base)))
  211.     (:complex
  212.      `(and (complexp ,n-object)
  213.            ,(once-only ((n-real `(realpart (the complex ,n-object)))
  214.                 (n-imag `(imagpart (the complex ,n-object))))
  215.           `(progn
  216.              ,n-imag ; ignorable
  217.              (and (typep ,n-real ',base)
  218.               ,@(when (eq class 'integer)
  219.                   `((typep ,n-imag ',base)))
  220.               ,(transform-numeric-bound-test n-real type base)
  221.               ,(transform-numeric-bound-test n-imag type
  222.                              base))))))))))
  223.  
  224.  
  225. ;;; Source-Transform-Hairy-Typep  --  Internal
  226. ;;;
  227. ;;;    Do the source transformation for a test of a hairy type.  AND, SATISFIES
  228. ;;; and NOT are converted into the obvious code.  We convert unknown types to
  229. ;;; %TYPEP, emitting an efficiency note if appropriate.
  230. ;;;
  231. (defun source-transform-hairy-typep (object type)
  232.   (declare (type hairy-type type))
  233.   (let ((spec (hairy-type-specifier type)))
  234.     (cond ((unknown-type-p type)
  235.        (when (policy nil (> speed brevity))
  236.          (compiler-note "Can't open-code test of unknown type ~S."
  237.                 (specifier-type type)))
  238.        `(%typep ,object ',spec))
  239.       (t
  240.        (ecase (first spec)
  241.          (satisfies `(if (funcall #',(second spec) ,object) t nil))
  242.          ((not and)
  243.           (once-only ((n-obj object))
  244.         `(,(first spec) ,@(mapcar #'(lambda (x) 
  245.                           `(typep ,n-obj ',x))
  246.                       (rest spec))))))))))
  247.  
  248.  
  249. ;;; Source-Transform-Union-Typep  --  Internal
  250. ;;;
  251. ;;;    Do source transformation for Typep of a known union type.  If a union
  252. ;;; type contains LIST, then we pull that out and make it into a single LISTP
  253. ;;; call.  Note that if SYMBOL is in the union, then LIST will be a subtype
  254. ;;; even without there being any (member NIL).  We just drop through to the
  255. ;;; general code in this case, rather than trying to optimize it.
  256. ;;;
  257. (defun source-transform-union-typep (object type)
  258.   (let* ((types (union-type-types type))
  259.      (ltype (specifier-type 'list))
  260.      (mtype (find-if #'member-type-p types)))
  261.     (cond ((and mtype (csubtypep ltype type))
  262.        (let ((members (member-type-members mtype)))
  263.          (once-only ((n-obj object))
  264.            `(if (listp ,n-obj)
  265.             t
  266.             (typep ,n-obj 
  267.                '(or ,@(mapcar #'type-specifier
  268.                       (remove (specifier-type 'cons)
  269.                           (remove mtype types)))
  270.                 (member ,@(remove nil members))))))))
  271.       (t
  272.        (once-only ((n-obj object))
  273.          `(or ,@(mapcar #'(lambda (x)
  274.                 `(typep ,n-obj ',(type-specifier x)))
  275.                 types)))))))
  276.  
  277.  
  278. ;;; FIND-SUPERTYPE-PREDICATE  --  Internal
  279. ;;;
  280. ;;;    Return the predicate and type from the most specific entry in
  281. ;;; *TYPE-PREDICATES* that is a supertype of Type.
  282. ;;;
  283. (defun find-supertype-predicate (type)
  284.   (declare (type ctype type))
  285.   (let ((res nil)
  286.     (res-type nil))
  287.     (dolist (x (backend-type-predicates *backend*))
  288.       (let ((stype (car x)))
  289.     (when (and (csubtypep type stype)
  290.            (or (not res-type)
  291.                (csubtypep stype res-type)))
  292.       (setq res-type stype)
  293.       (setq res (cdr x)))))
  294.     (values res res-type)))
  295.  
  296.  
  297. ;;; TEST-ARRAY-DIMENSIONS  --  Internal
  298. ;;;
  299. ;;;    Return forms to test that Obj has the rank and dimensions specified by
  300. ;;; Type, where Stype is the type we have checked against (which is the same
  301. ;;; but for dimensions.)
  302. ;;;
  303. (defun test-array-dimensions (obj type stype)
  304.   (declare (type array-type type stype))
  305.   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
  306.     (dims (array-type-dimensions type)))
  307.     (unless (eq dims '*)
  308.       (collect ((res))
  309.     (when (eq (array-type-dimensions stype) '*)
  310.       (res `(= (array-rank ,obj) ,(length dims))))
  311.  
  312.     (do ((i 0 (1+ i))
  313.          (dim dims (cdr dim)))
  314.         ((null dim))
  315.       (let ((dim (car dim)))
  316.         (unless (eq dim '*)
  317.           (res `(= (array-dimension ,obj ,i) ,dim)))))
  318.     (res)))))
  319.  
  320.  
  321. ;;; SOURCE-TRANSFORM-ARRAY-TYPEP  --  Internal
  322. ;;;
  323. ;;;    If we can find a type predicate that tests for the type w/o dimensions,
  324. ;;; then use that predicate and test for dimensions.  Otherwise, just do
  325. ;;; %TYPEP.
  326. ;;;
  327. (defun source-transform-array-typep (obj type)
  328.   (multiple-value-bind (pred stype)
  329.                (find-supertype-predicate type)
  330.     (if (and (array-type-p stype)
  331.          (type= (array-type-specialized-element-type stype)
  332.             (array-type-specialized-element-type type))
  333.          (eq (array-type-complexp stype) (array-type-complexp type)))
  334.     (once-only ((n-obj obj))
  335.       `(and (,pred ,n-obj)
  336.         ,@(test-array-dimensions n-obj type stype)))
  337.     `(%typep ,obj ',(type-specifier type)))))
  338.  
  339.  
  340. ;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP  --  Internal
  341. ;;;
  342. ;;;    If not currently defined as a structure to the compiler (must have been
  343. ;;; undefined) or there is no predicate, then we call STRUCTURE-TYPEP.
  344. ;;; Otherwise, we do an EQ test for a direct type match, and if that fails,
  345. ;;; deal with inherited types.  If the type is frozen, we can inline the
  346. ;;; supertype check, otherwise we have to call the predicate.
  347. ;;;
  348. (defun source-transform-structure-typep (obj desc)
  349.   (let* ((type (structure-type-name desc))
  350.      (def (info type structure-info type)))
  351.     (cond
  352.      ((not def)
  353.       `(lisp::structure-typep ,obj ',type))
  354.      ((not (eq (dd-type def) 'structure))
  355.       (compiler-error "Structure type has :TYPE specified, so it can't ~
  356.                      be used as an argument to TYPEP:~%  ~S"
  357.               type))
  358.      (t
  359.       (let ((frozen (info type frozen type))
  360.         (included (dd-included-by def))
  361.         (predicate (dd-predicate def))
  362.         (n-name (gensym)))
  363.     (if (or frozen predicate)
  364.         (once-only ((object obj))
  365.           `(and (structurep ,object)
  366.             (let ((,n-name (structure-ref ,object 0)))
  367.               (if (eq ,n-name ',type)
  368.               t
  369.               ,(if frozen
  370.                    (when included
  371.                  `(if (member ,n-name ',included :test #'eq)
  372.                       t nil))
  373.                    `(locally (declare (notinline ,predicate))
  374.                   (,predicate ,object)))))))
  375.         `(lisp::structure-typep ,obj ',type)))))))
  376.  
  377.  
  378. ;;; Source-Transform-Typep  --  Internal
  379. ;;;
  380. ;;;    If the specifier argument is a quoted constant, then we consider
  381. ;;; converting into a simple predicate or other stuff.  If the type is
  382. ;;; constant, but we can't transform the call, then we convert to %Typep.  We
  383. ;;; only pass when the type is non-constant.  This allows us to recognize
  384. ;;; between calls that might later be transformed sucessfully when a constant
  385. ;;; type is discovered.  We don't given an efficiency note when we pass, since
  386. ;;; the IR1 transform will give one if necessary and appropriate.
  387. ;;;
  388. ;;; If the type is Type= to a type that has a predicate, then expand to that
  389. ;;; predicate.  Otherwise, we dispatch off of the type's type.  These
  390. ;;; transformations can increase space, but it is hard to tell when, so we
  391. ;;; ignore policy and always do them.
  392. ;;;
  393. (def-source-transform typep (object spec)
  394.   (if (and (consp spec) (eq (car spec) 'quote))
  395.       (let* ((type (specifier-type (cadr spec)))
  396.          (pred (cdr (assoc type (backend-type-predicates *backend*)
  397.                    :test #'type=))))
  398.     (if pred
  399.         `(,pred ,object)
  400.         (typecase type
  401.           (numeric-type
  402.            (source-transform-numeric-typep object type))
  403.           (hairy-type
  404.            (source-transform-hairy-typep object type))
  405.           (union-type
  406.            (source-transform-union-typep object type))
  407.           (member-type
  408.            `(member ,object ',(member-type-members type)))
  409.           (structure-type
  410.            (source-transform-structure-typep object type))
  411.           (args-type
  412.            (compiler-warning "Illegal type specifier for Typep: ~S."
  413.                  (cadr spec))
  414.            `(%typep ,object ,spec))
  415.           (array-type
  416.            (source-transform-array-typep object type))
  417.           (t
  418.            `(%typep ,object ,spec)))))
  419.       (values nil t)))
  420.